home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / matt's utils 8sept / object-dropper.lisp < prev    next >
Encoding:
Text File  |  1992-09-08  |  11.9 KB  |  325 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; object-dropper.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines a extensible object drop functionality.
  10.  
  11. Generic functions specify the interface.
  12.  
  13. This program's users must implement their own policy for deciding when a
  14. drop is initiated (i.e. when track-mouse-for-dropping is called). Some
  15. possibilities are:
  16.  
  17. - When an already-selected item is clicked on.
  18. - When a certain modifier key combination is present (e.g. command-option).
  19.  
  20.  
  21. ================================================================
  22. Status =========================================================
  23. ================================================================
  24. Released.
  25.  
  26. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  27. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  28.  
  29.  
  30. ================================================================
  31. Change history =================================================
  32. ================================================================
  33. 02-Aug-92 mc    Created.
  34. 03-Aug-92 mc    Improved demo. Added optimize speed.
  35. 06-Aug-92 mc    Changed macptr-region-global and track-mouse-for-dropping to
  36.          take object and pt-global-starting.
  37. 15-Aug-92 mc    Uncommented example fred-mixin code.
  38.         Moved object-fred-dialog-item hook to
  39.          "object-FDI-drop-glue.lisp" .
  40. 18-Aug-92 mc    Defined and exported invert-inside-gray-frame .
  41. 08-Sep-92 mc    Fixed unmatched ) in example code.
  42.  
  43. |#
  44.  
  45.  
  46. (in-package "CCL")
  47.  
  48. (require "DRAG-GRAY-REGION-LISP" "CCL:UMASS Utils;drag-gray-region-lisp")
  49.  
  50. (export '(F-CAN-RECEIVE-DROP
  51.           INVERT-DROP-HIGHLIGHT
  52.           RECEIVE-DROP
  53.           MACPTR-REGION-GLOBAL
  54.           TRACK-MOUSE-FOR-DROPPING
  55.           INVERT-INSIDE-GRAY-FRAME))
  56.  
  57.  
  58. ;;;================================================================
  59. ;;; Define functions related to receiving drops.
  60. ;;;================================================================
  61.  
  62. (defgeneric f-can-receive-drop (view object pt-global)
  63.   (:documentation "Returns non-nil if view can receive-drop object at
  64. pt-global."))
  65.  
  66.  
  67. (defmethod f-can-receive-drop ((view simple-view) (object t) (pt-global integer))
  68.   "Returns nil."
  69.   ;;
  70.   nil)
  71.  
  72.  
  73. (defgeneric invert-drop-highlight (view object pt-global)
  74.   (:documentation "Indicates visually what dropping object might do. It is
  75. critical that drawing be done in :patXOr mode so that it can be undone
  76. while tracking. Pt-global is the current mouse position."))
  77.  
  78.  
  79. (defmethod invert-drop-highlight ((view simple-view) (object t) (pt-global integer))
  80.   ;;
  81.   (error "~S doesn't know how to invert highlights." view))
  82.  
  83.  
  84. (defgeneric receive-drop (view object pt-global)
  85.   (:documentation "Takes the dropped action on object. Pt-global is the
  86. mouse position when it was released."))
  87.  
  88.  
  89. (defmethod receive-drop ((view simple-view) (object t) (pt-global integer))
  90.   ;;
  91.   (error "~S doesn't know how to receive drops." view))
  92.  
  93.  
  94. ;;;================================================================
  95. ;;; Define functions related to starting drops.
  96. ;;;================================================================
  97.  
  98. (defgeneric macptr-region-global (view object pt-global-starting)
  99.   (:documentation "Returns the region to be used while
  100. track-mouse-for-dropping is running, which disposes of the region when
  101. it's through. Object is the object being carried and pt-global-starting
  102. is the global point the mouse went down at when tracking started."))
  103.  
  104.  
  105. (defmethod macptr-region-global ((view simple-view)
  106.                                  (object t)
  107.                                  (pt-global-starting integer))
  108.   "Returns a rectangular region that matches view's size and position."
  109.   (declare (optimize speed)
  110.            (ignore pt-global-starting))
  111.   ;;
  112.   (let* ((macptr-region-global (#_NewRgn))
  113.          (pt-top-left (local-to-global view 0))
  114.          (pt-bottom-right (local-to-global view (view-size view))))
  115.     (rlet ((rect :rect :topLeft pt-top-left :bottomRight pt-bottom-right))
  116.       (#_RectRgn macptr-region-global rect)
  117.       macptr-region-global)))
  118.  
  119.  
  120. (defgeneric track-mouse-for-dropping (view-starting object pt-global-starting
  121.                                                     &key cursor)
  122.   (:documentation "Initiates mouse tracking from view-starting. The loop
  123. 'carries' object by calling invert-drop-highlight on views that
  124. f-can-receive-drop. If the mouse is released over one that can, then
  125. receive-drop is called on it. Pt-global-starting is the global point the
  126. mouse went down at when tracking started. Cursor is a macptr of a cursor
  127. used during tracking, and defaults to *arrow-cursor*. Returns the view
  128. dropped on."))
  129.  
  130.  
  131. (defmethod track-mouse-for-dropping ((view-starting simple-view)
  132.                                      (object t)
  133.                                      (pt-global-starting integer)
  134.                                      &key (cursor *arrow-cursor*))
  135.   (declare (optimize speed))
  136.   ;;
  137.   (let* ((macptr-region-global
  138.           (macptr-region-global view-starting object pt-global-starting))
  139.          (pt-global-last (view-mouse-position nil))
  140.          (view-last nil)
  141.          (view-current (find-view-containing-point nil pt-global-last)))
  142.     ;;
  143.     ;; Should not call f-can-receive-drop, invert-drop-highlight, or
  144.     ;;  invert-drop-highlight on view-starting. Fix!
  145.     ;;
  146.     (drag-gray-region-lisp
  147.      macptr-region-global
  148.      #'(lambda (pt-global-current)
  149.          (setf view-current (find-view-containing-point nil pt-global-current))
  150.          ;;
  151.          ;; There are two interesting cases. (In either case we aren't
  152.          ;;  interested in moving into or out of view-start.)
  153.          ;;
  154.          ;; - The mouse moved out of view-last.
  155.          ;; - The mouse moved into view-current.
  156.          ;;
  157.          ;; Invert (dehighlight) the old.
  158.          (when (and view-last
  159.                     (neq view-last view-starting)
  160.                     (f-can-receive-drop view-last object pt-global-last))
  161.            (invert-drop-highlight view-last object pt-global-last))
  162.          ;; Invert (highlight) the new.
  163.          (when (and view-current
  164.                     (neq view-current view-starting)
  165.                     (f-can-receive-drop view-current object pt-global-current))
  166.            (invert-drop-highlight view-current object pt-global-current))
  167.          ;;
  168.          (setf pt-global-last pt-global-current
  169.                view-last view-current))
  170.      pt-global-last
  171.      :cursor cursor)
  172.     ;; Dispose, and invert last and call receive-drop on view-last, if it
  173.     ;;  wasn't view-starting.
  174.     (#_DisposeRgn macptr-region-global)
  175.     (when (and view-last
  176.                (neq view-last view-starting)
  177.                (f-can-receive-drop view-last object pt-global-last))
  178.       (invert-drop-highlight view-last object pt-global-last)
  179.       (receive-drop view-last object pt-global-last))))
  180.  
  181.  
  182. (unless (fboundp 'local-to-global)
  183.   ;; From "quickdraw.lisp" :
  184.   (defmethod local-to-global ((view simple-view) h &optional v)
  185.     (with-focused-view view
  186.       (rlet ((p :point))
  187.         (%put-long p (make-point h v))
  188.         (#_LocalToGlobal p)
  189.         (%get-long p)))))
  190.  
  191. ;;;================================================================
  192. ;;; Tell fred-mixins how to receive drops.
  193. ;;;================================================================
  194.  
  195. (defmethod f-can-receive-drop ((view fred-mixin) (object t) (pt-global integer))
  196.   (declare (ignore object))
  197.   ;;
  198.   (fred-point-position view (global-to-local view pt-global)))
  199.  
  200.  
  201. (unless (fboundp 'global-to-local)
  202.   ;; From "quickdraw.lisp" :
  203.   (defmethod global-to-local ((view simple-view) h &optional v)
  204.     (with-focused-view view
  205.       (rlet ((p :point))
  206.         (%put-long p (make-point h v))
  207.         (#_GlobalToLocal p)
  208.         (%get-long p)))))
  209.  
  210.  
  211. (defmethod invert-drop-highlight ((view fred-mixin) (object t) (pt-global integer))
  212.   "Invert a vertical bar at view's buffer position corresponding to
  213. pt-global."
  214.   ;;
  215.   (let* ((int-index (fred-point-position view (global-to-local view pt-global)))
  216.          (int-pos-horizontal-bottom (fred-hpos view int-index))
  217.          (int-pos-vertical (fred-vpos view int-index))
  218.          (int-height-line (- (fred-line-vpos view 1)
  219.                              (fred-line-vpos view 0))))
  220.     (with-focused-view view
  221.       (with-pen-saved
  222.         (#_PenMode (position :PATXOR *pen-modes*))
  223.         ;; #_PenPat Needed only for object-fred-dialog-items, which
  224.         ;;  inverted in *gray-pattern* (fred-mixins worked fine):
  225.         (#_PenPat *black-pattern*)
  226.         (#_MoveTo int-pos-horizontal-bottom int-pos-vertical)
  227.         (#_Line 0 (- int-height-line))))))
  228.  
  229.  
  230. (defmethod receive-drop ((view fred-mixin) (object t) (pt-global integer))
  231.   ;;
  232.   (ed-insert-with-undo view (format nil "~A" object)
  233.                        (fred-point-position view (global-to-local view pt-global)))
  234.   (fred-update view))
  235.  
  236.  
  237. ;;;================================================================
  238. ;;; Define some handy drop-highlight functions.
  239. ;;;================================================================
  240.  
  241. (defmethod invert-inside-gray-frame ((view simple-view))
  242.   "Inverts a gray frame just inside view. (Headache if it's thick!)"
  243.   (declare (optimize speed))
  244.   ;;
  245.   (let* ((pt-top-left #@(0 0))
  246.          (pt-bottom-right (view-size view)))
  247.     (rlet ((rect :rect :topLeft pt-top-left :bottomRight pt-bottom-right))
  248.       (with-focused-view view
  249.         (with-pen-saved
  250.           (#_PenMode (position :PATXOR *pen-modes*))
  251.           (#_PenPat *gray-pattern*)
  252.           (#_PenSize 3 3)
  253.           (#_FrameRect rect))))))
  254.  
  255.  
  256. ;;;================================================================
  257. ;;; Done.
  258. ;;;================================================================
  259.  
  260. (provide "OBJECT-DROPPER")
  261.  
  262.  
  263. #|
  264. ;;; See object-FDI-drop-glue.lisp for another example.
  265.  
  266. ;;; Define sample code.
  267.  
  268. ;;;
  269. ;;; Make items that can start and receive drops.
  270. ;;;
  271.  
  272. (defclass receive-button-dialog-item (button-dialog-item)
  273.   ((sym-function
  274.     :accessor sym-function-rbdi
  275.     :initarg :sym-function
  276.     :initform 'describe
  277.     :type symbol
  278.     :documentation "A symbol with a function definition. The definition is
  279. run by receive-drop on the object dropped."))
  280.   (:documentation "Runs sym-function-rbdi on dropped items."))
  281.  
  282. (defmethod initialize-instance :after ((receive-button-dialog-item receive-button-dialog-item)
  283.                                      &key dialog-item-text)
  284.   (unless dialog-item-text
  285.     (set-dialog-item-text
  286.      receive-button-dialog-item
  287.      (format nil "~:(~A~)" (sym-function-rbdi receive-button-dialog-item)))))
  288.  
  289. (defmethod f-can-receive-drop ((view receive-button-dialog-item) (object t) (pt-global integer))
  290.   t)
  291.  
  292. (defmethod invert-drop-highlight ((view receive-button-dialog-item) (object t) (pt-global integer))
  293.   ;; Invert a gray frame just inside view. (Headache if it's thick!)
  294.   (invert-inside-gray-frame view))
  295.  
  296.  
  297. (defmethod receive-drop ((view receive-button-dialog-item) (object t) (pt-global integer))
  298.   (funcall (symbol-function (sym-function-rbdi view))
  299.            object))
  300.  
  301.  
  302. (defun test-dropper ()
  303.   (let* ((window (make-instance 'window
  304.                    :window-title "Test Dropper"
  305.                    :view-position #@(475 41)
  306.                    :view-size #@(169 58)))
  307.          (start-dialog-item (make-instance 'button-dialog-item
  308.                               :view-size #@(80 20)
  309.                               :view-position #@(5 5)
  310.                               :view-font '("Geneva" 9)
  311.                               :dialog-item-text "Start Tracking"))
  312.          (receive-dialog-item (make-instance 'receive-button-dialog-item
  313.                                 :view-size #@(80 20)
  314.                                 :view-position #@(20 30)
  315.                                 :view-font '("Geneva" 9))))
  316.     (add-subviews window start-dialog-item receive-dialog-item)
  317.     ;;
  318.     (defmethod view-click-event-handler ((view (eql start-dialog-item))
  319.                                          where)
  320.       ;;
  321.       (track-mouse-for-dropping
  322.        view view (local-to-global (view-container view) where)))
  323.     window))
  324.  
  325. |#